home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xscheme.arc / xscheme.c < prev    next >
C/C++ Source or Header  |  1989-01-29  |  3KB  |  161 lines
  1. /* xscheme.c - xscheme main routine */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7.  
  8. /* the program banner */
  9. #define BANNER    "XScheme - Version 0.16"
  10.  
  11. /* global variables */
  12. jmp_buf top_level;
  13.  
  14. /* trace file pointer */
  15. FILE *tfp=NULL;
  16.  
  17. /* external variables */
  18. extern LVAL xlfun,xlenv,xlval;
  19. extern LVAL s_stdin,s_stdout,s_stderr,s_unbound;
  20.  
  21. /* external routines */
  22. extern FILE *osifile();
  23.  
  24. /* main - the main routine */
  25. main()
  26. {
  27.     LVAL code;
  28.     
  29.     /* initialize */
  30.     osinit(BANNER);
  31.     
  32.     /* restore the default workspace, otherwise create a new one */
  33.     if (!xlirestore("xscheme.wks"))
  34.     xlinitws(5000);
  35.  
  36.     /* do the initialization code first */
  37.     code = xlenter("*INITIALIZE*");
  38.     code = (boundp(code) ? getvalue(code) : NIL);
  39.  
  40.     /* trap errors */
  41.     if (setjmp(top_level)) {
  42.     code = xlenter("*TOPLEVEL*");
  43.     code = (boundp(code) ? getvalue(code) : NIL);
  44.     xlfun = xlenv = xlval = NIL;
  45.     xlsp = xlstktop;
  46.     }
  47.  
  48.     /* execute the main loop */
  49.     if (code != NIL)
  50.     xlexecute(code);
  51.     wrapup();
  52. }
  53.  
  54. xlload() {}
  55. xlcontinue() {}
  56. xlbreak() { xltoplevel(); }
  57. xlcleanup() {}
  58.  
  59. /* xltoplevel - return to the top level */
  60. xltoplevel()
  61. {
  62.     stdputstr("[ back to top level ]\n");
  63.     longjmp(top_level,1);
  64. }
  65.  
  66. /* xlfail - report an error */
  67. xlfail(msg)
  68.   char *msg;
  69. {
  70.     xlerror(msg,s_unbound);
  71. }
  72.  
  73. /* xlerror - report an error */
  74. xlerror(msg,arg)
  75.   char *msg; LVAL arg;
  76. {
  77.     /* display the error message */
  78.     errputstr("Error: ");
  79.     errputstr(msg);
  80.     errputstr("\n");
  81.     
  82.     /* print the argument on a separate line */
  83.     if (arg != s_unbound) {
  84.     errputstr("  ");
  85.     errprint(arg);
  86.     }
  87.     
  88.     /* print the function where the error occurred */
  89.     errputstr("happened in: ");
  90.     errprint(xlfun);
  91.  
  92.     /* call the handler */
  93.     callerrorhandler();
  94. }
  95.  
  96. /* callerrorhandler - call the error handler */
  97. callerrorhandler()
  98. {
  99.     extern jmp_buf bc_dispatch;
  100.     
  101.     /* invoke the error handler */
  102.     if (xlval = getvalue(xlenter("*ERROR-HANDLER*"))) {
  103.     oscheck();    /* an opportunity to break out of a bad handler */
  104.     check(2);
  105.     push(xlenv);
  106.     push(xlfun);
  107.     xlargc = 2;
  108.     xlapply();
  109.     longjmp(bc_dispatch,1);
  110.     }
  111.  
  112.     /* no handler, just reset back to the top level */
  113.     longjmp(top_level,1);
  114. }
  115.  
  116. /* xlabort - print an error message and abort */
  117. xlabort(msg)
  118.   char *msg;
  119. {
  120.     /* display the error message */
  121.     errputstr("Abort: ");
  122.     errputstr(msg);
  123.     errputstr("\n");
  124.     
  125.     /* print the function where the error occurred */
  126.     errputstr("happened in: ");
  127.     errprint(xlfun);
  128.  
  129.     /* reset back to the top level */
  130.     oscheck();    /* an opportunity to break out */
  131.     longjmp(top_level,1);
  132. }
  133.  
  134. /* xlfatal - print a fatal error message and exit */
  135. xlfatal(msg)
  136.   char *msg;
  137. {
  138.     oserror(msg);
  139.     exit(1);
  140. }
  141.  
  142. /* info - display debugging information */
  143. info(fmt,a1,a2,a3,a4)
  144.   char *fmt;
  145. {
  146.     char buf[100],*p;
  147.     sprintf(buf,fmt,a1,a2,a3,a4);
  148.     for (p = buf; *p != '\0'; )
  149.     ostputc(*p++);
  150. }
  151.  
  152. /* wrapup - clean up and exit to the operating system */
  153. wrapup()
  154. {
  155.     if (tfp)
  156.     osclose(tfp);
  157.     osfinish();
  158.     exit(0);
  159. }
  160.  
  161.